home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / xlisp21.zip / PT.LSP < prev    next >
Text File  |  1988-02-12  |  3KB  |  121 lines
  1. ; This is a sample XLISP program.
  2. ; It implements a simple form of programmable turtle
  3. ; It only works on the Macintosh version of XLISP at the moment.
  4.  
  5. ; To run it:
  6.  
  7. ;    (load "pt.lsp")
  8.  
  9. ; This should cause the screen to be cleared and two turtles to appear.
  10. ; They should each execute their simple programs and then the prompt
  11. ; should return.  Look at the code to see how all of this works.
  12.  
  13. ; Get some more memory
  14. (expand 1)
  15.  
  16. ; ::::::::::::
  17. ; :: Turtle ::
  18. ; ::::::::::::
  19.  
  20. ; Define "Turtle" class
  21. (setq Turtle (send Class :new '(xpos ypos)))
  22.  
  23. ; Answer ":isnew" by initing a position and char and displaying.
  24. (send Turtle :answer :isnew '(x y) '(
  25.     (setq xpos x)
  26.     (setq ypos y)
  27.     (send self :display)
  28.     self))
  29.  
  30. ; Message ":display" prints its char at its current position
  31. (send Turtle :answer :display '() '(
  32.     (moveto xpos ypos)
  33.     (lineto xpos ypos)
  34.     self))
  35.  
  36. ; Message ":goto" goes to a new place after clearing old one
  37. (send Turtle :answer :goto '(x y) '(
  38.     (moveto xpos ypos)
  39.     (setq xpos x)
  40.     (setq ypos y)
  41.     (lineto xpos ypos)
  42.     self))
  43.  
  44. ; Message ":up" moves up
  45. (send Turtle :answer :up '() '(
  46.     (send self :goto xpos (- ypos 10))))
  47.  
  48. ; Message ":down" moves down
  49. (send Turtle :answer :down '() '(
  50.     (send self :goto xpos (+ ypos 10))))
  51.  
  52. ; Message ":right" moves right
  53. (send Turtle :answer :right '() '(
  54.     (send self :goto (+ xpos 10) ypos)))
  55.  
  56. ; Message ":left" moves left
  57. (send Turtle :answer :left '() '(
  58.     (send self :goto (- xpos 10) ypos)))
  59.  
  60.  
  61. ; :::::::::::::
  62. ; :: PTurtle ::
  63. ; :::::::::::::
  64.  
  65. ; Define "DPurtle" programable turtle class
  66. (setq PTurtle (send Class :new '(prog pc) '() Turtle))
  67.  
  68. ; Message ":program" stores a program
  69. (send PTurtle :answer :program '(p) '(
  70.     (setq prog p)
  71.     (setq pc prog)
  72.     self))
  73.  
  74. ; Message ":step" executes a single program step
  75. (send PTurtle :answer :step '() '(
  76.     (if (null pc)
  77.     (setq pc prog))
  78.     (if pc
  79.     (progn (send self (car pc))
  80.            (setq pc (cdr pc))))
  81.     self))
  82.  
  83. ; Message ":step:" steps each turtle program n times
  84. (send PTurtle :answer :step: '(n) '(
  85.     (dotimes (x n) (send self :step))
  86.     self))
  87.  
  88.  
  89. ; ::::::::::::::
  90. ; :: PTurtles ::
  91. ; ::::::::::::::
  92.  
  93. ; Define "PTurtles" class
  94. (setq PTurtles (send Class :new '(turtles)))
  95.  
  96. ; Message ":make" makes a programable turtle and adds it to the collection
  97. (send PTurtles :answer :make '(x y &aux newturtle) '(
  98.     (setq newturtle (send PTurtle :new x y))
  99.     (setq turtles (cons newturtle turtles))
  100.     newturtle))
  101.  
  102. ; Message ":step" steps each turtle program once
  103. (send PTurtles :answer :step '() '(
  104.     (mapcar #'(lambda (turtle) (send turtle :step)) turtles)
  105.     self))
  106.  
  107. ; Message ":step:" steps each turtle program n times
  108. (send PTurtles :answer :step: '(n) '(
  109.     (dotimes (x n) (send self :step))
  110.     self))
  111.  
  112.  
  113. ; Create some programmable turtles
  114. (setq turtles (send PTurtles :new))
  115. (setq t1 (send turtles :make 200 100))
  116. (setq t2 (send turtles :make 210 100))
  117. (send t1 :program '(:left :left :up :right :up))
  118. (send t2 :program '(:right :right :down :left :down))
  119. (show-graphics)
  120. (send turtles :step: 20)
  121.